MacTech 1 to 12/MacTech-vol-1-12.toast/Source/Peter Lewis (TCPExample)/PNL Libraries/MyStrings.p

Text File | 1995-12-01 | 11.6 KB | 505 lines | [TEXT/CWIE]

unit MyStrings;

interface

    uses
        Types, MyTypes;

    procedure LeftP (var s: Str255; len: integer);
    function Left (var s: Str255; len: integer): Str255;
    procedure LeftAssignP (var s: Str255; len: integer; var rhs: Str255);
    function LeftAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
    procedure RightP (var s: Str255; len: integer);
    function Right (var s: Str255; len: integer): Str255;
    procedure RightAssignP (var s: Str255; len: integer; var rhs: Str255);
    function RightAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
    procedure MidP (var s: Str255; p, len: integer);
    function Mid (var s: Str255; p, len: integer): Str255;
    procedure MidAssignP (var s: Str255; p, len: integer; var rhs: Str255);
    function MidAssign (var s: Str255; p, len: integer; var rhs: Str255): Str255;
    procedure HandleToString (hhhh: univ handle; var s: Str255);
    function HandleToStr (hhhh: univ handle): Str255;
    procedure StringToHandle (var s: Str255; hhhh: univ handle);
    function Trim (s: string): string;
    function UpCase (ch: char): char;
{$IFC not GENERATINGPOWERPC}
    inline
        $301F, $0C00, $0061, $6500, $000E, $0C00, $007B, $6400, $0006, $0400, $0020, $3E80;
{$ENDC}
    function IsDigit(ch:char):boolean;
{$IFC not GENERATINGPOWERPC}
    inline
        $321F,$0C41,$0030,$5CC0,$6D08,$0C41,$0039,$6F02,$5FC0,$4400,$1E80;
{$ENDC}
    function IsLower(ch:char):boolean;
{$IFC not GENERATINGPOWERPC}
    inline
        $321F,$0C41,$0061,$5CC0,$6D08,$0C41,$007A,$6F02,$5FC0,$4400,$1E80;
{$ENDC}
    function IsUpper(ch:char):boolean;
{$IFC not GENERATINGPOWERPC}
    inline
        $321F,$0C41,$0041,$5CC0,$6D08,$0C41,$005A,$6F02,$5FC0,$4400,$1E80;
{$ENDC}
    function IsAlpha(ch:char):boolean;
{$IFC not GENERATINGPOWERPC}
    inline
        $321F,$0C41,$0041,$5CC0,$6D16,$0C41,$005A,$6F10,$0C41,$0061,$5CC0,$6D08,$0C41,$007A,$6F02,$5FC0,$4400,$1E80;
{$ENDC}

    procedure UpCaseString (var s: string);
    function UpCaseStr (s: string): string;
{    procedure SPrintS5V (var dst: Str255;var  src,s1, s2, s3, s4, s5: Str255);}
    procedure SPrintS5 (var dst: Str255; src, s1, s2, s3, s4, s5: Str255);
    procedure SPrintS3 (var dst: Str255; src, s1, s2, s3: Str255);
    function PosRight (sub, s: Str255): integer;
    procedure SplitRightBy (s: Str255; ch: char; var left, right: Str255);
    procedure SplitBy (s: Str255; ch: char; var left, right: Str255);
    function Split (sub, s: Str255; var s1, s2: Str255): boolean;
    function SplitRight (sub, s: Str255; var s1, s2: Str255): boolean;
    function TPpos (sub, str: string): integer;
    function TPcopy (source: string; start, count: integer): string;
    procedure TPCopyString(var source,dest: string; destlen:integer);
    function Match (pattern, name: Str255): boolean;
    procedure LimitStringLength (var s: string; len: integer; delimiter: char);
    function StringToOSType (s: Str255): OSType;
    function OSTypeToString (t: OSType): Str255;
    function FindCharacter(p:Ptr; len:longint; ch:Char; var pos:longint):boolean;

implementation

    uses
        Memory, OSUtils, TextUtils, MyMathUtils, QLowLevel;

    function FindCharacter(p:Ptr; len:longint; ch:Char; var pos:longint):boolean;
    begin
        pos:=0;
        while (pos<len) & (AddPtrLong(p,pos)^<>ord(ch)) do begin
            pos:=pos+1;
        end;
        FindCharacter:= pos<len;
    end;

    procedure LeftP (var s: Str255; len: integer);
    begin
        s := TPcopy(s, 1, len);
    end;

    function Left (var s: Str255; len: integer): Str255;
    begin
        Left := TPcopy(s, 1, len);
    end;

    procedure LeftAssignP (var s: Str255; len: integer; var rhs: Str255);
    begin
        s := concat(rhs, TPcopy(s, len + 1, 255));
    end;

    function LeftAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
    begin
        LeftAssign := concat(rhs, TPcopy(s, len + 1, 255));
    end;

    procedure RightP (var s: Str255; len: integer);
        var
            p: integer;
    begin
        p := Length(s) - len;
        if p < 1 then begin
            p := 1;
        end;
        s := TPcopy(s, p, 255);
    end;

    function Right (var s: Str255; len: integer): Str255;
        var
            p: integer;
    begin
        p := Length(s) - len;
        if p < 1 then begin
            p := 1;
        end;
        Right := TPcopy(s, p, 255);
    end;

    procedure RightAssignP (var s: Str255; len: integer; var rhs: Str255);
    begin
        s := concat(TPcopy(s, 1, Length(s) - len), rhs);
    end;

    function RightAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
    begin
        RightAssign := concat(TPcopy(s, 1, Length(s) - len), rhs);
    end;

    procedure MidP (var s: Str255; p, len: integer);
    begin
        s := TPcopy(s, p, len);
    end;

    function Mid (var s: Str255; p, len: integer): Str255;
    begin
        Mid := TPcopy(s, p, len);
    end;

    procedure MidAssignP (var s: Str255; p, len: integer; var rhs: Str255);
    begin
        s := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len + 1, 255));
    end;

    function MidAssign (var s: Str255; p, len: integer; var rhs: Str255): Str255;
    begin
        MidAssign := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len + 1, 255));
    end;

{$PUSH}
{$R-}
    procedure HandleToString (hhhh: univ handle; var s: Str255);
        var
            len: longint;
    begin
        len := Min(255, GetHandleSize(hhhh));
        s[0] := chr(len);
        BlockMoveData(hhhh^, @s[1], len);
    end;
{$POP}

    function HandleToStr (hhhh: univ handle): Str255;
        var
            s: Str255;
    begin
        HandleToString(hhhh, s);
        HandleToStr := s;
    end;

{$PUSH}
{$R-}
    procedure StringToHandle (var s: Str255; hhhh: univ handle);
    begin
        SetHandleSize(hhhh, length(s));
        BlockMoveData(@s[1], hhhh^, length(s));
    end;
{$POP}

    function Trim (s: string): string;
    begin
        while (length(s) > 0) and (s[1] in [spc, tab, cr, lf]) do begin
            Delete(s, 1, 1);
        end;
        while (length(s) > 0) and (s[length(s)] in [spc, tab, cr, lf]) do begin
            Delete(s, length(s), 1);
        end;
        Trim := s;
    end;

{$IFC GENERATINGPOWERPC}
    function UpCase (ch: char): char;
    begin
        if ('a' <= ch) & (ch <= 'z') then begin
            ch := chr(ord(ch) - $20);
        end;
        UpCase := ch;
    end;

    function IsDigit(ch:char):boolean;
    begin
        IsDigit:=('0'<=ch) & (ch<='9');
    end;

    function IsLower(ch:char):boolean;
    begin
        IsLower:=('a'<=ch) & (ch<='z');
    end;

    function IsUpper(ch:char):boolean;
    begin
        IsUpper:=('A'<=ch) & (ch<='Z');
    end;

    function IsAlpha(ch:char):boolean;
    begin
        IsAlpha:=(('a'<=ch) & (ch<='z')) | (('A'<=ch) & (ch<='Z'));
    end;
{$ENDC}

    procedure UpCaseString (var s: string);
        var
            i: integer;
    begin
        for i := 1 to length(s) do begin
            s[i] := UpCase(s[i]);
        end;
    end;

    function UpCaseStr (s: string): string;
        var
            i: integer;
    begin
        for i := 1 to length(s) do begin
            s[i] := UpCase(s[i]);
        end;
        UpCaseStr := s;
    end;

    procedure TPCopyString(var source,dest: string; destlen:integer);
    begin
        destlen := Min(destlen,length(source)+1);
        BlockMoveData(@source,@dest,destlen);
        dest[0] := chr(destlen-1);
    end;

    function TPcopy (source: string; start, count: integer): string;
    begin
        if (start < 1) then begin
            count := count - (1 - start);
            start := 1;
        end;
        if start + count > length(source) then begin
            count := length(source) - start + 1;
        end;
        if count < 0 then begin
            count := 0;
        end;
        source[0] := chr(count);
        BlockMoveData(@source[start], @source[1], count);
        TPcopy := source;
    end;

    function TPpos (sub, str: string): integer;
        var
            i, j, ret: integer;
    begin
        i := 1;
        ret := 1;
        if length(sub) > 0 then begin
            ret := 0;
            while (i <= length(str) - length(sub) + 1) do begin
                if str[i] = sub[1] then begin
                    j:=2;
                    while j<=length(sub) do begin
                        if str[i+j-1]<>sub[j] then begin
                            leave;
                        end;
                        j:=j+1;
                    end;
                    if j>length(sub) then begin
                        ret:=i;
                        leave;
                    end;
                end;
                i := i + 1;
            end;
        end;
        TPpos := ret;
    end;

    procedure DoSub (var dst: Str255; n: integer; var s: Str255);
        var
            p: integer;
    begin
        p := TPpos(concat('^', chr(n + 48)), dst);
        if p > 0 then begin
            Delete(dst, p, 2);
            Insert(s, dst, p);
        end;
    end;

{$Z+}
    procedure SPrintS5V (var dst: Str255; var src, s1, s2, s3, s4, s5: Str255);
    begin
        dst := src;
        DoSub(dst, 5, s5);
        DoSub(dst, 4, s4);
        DoSub(dst, 3, s3);
        DoSub(dst, 2, s2);
        DoSub(dst, 1, s1);
    end;
{$Z-}

    procedure SPrintS5 (var dst: Str255; src, s1, s2, s3, s4, s5: Str255);
    begin
        SPrintS5V(dst, src, s1, s2, s3, s4, s5);
    end;

    procedure SPrintS3 (var dst: Str255; src, s1, s2, s3: Str255);
    begin
        dst := src;
        DoSub(dst, 3, s3);
        DoSub(dst, 2, s2);
        DoSub(dst, 1, s1);
    end;

    function PosRight (sub, s: Str255): integer;
        var
            p, q: integer;
    begin
        p := TPpos(sub, s);
        if p > 0 then begin
            q := length(s) - length(sub) + 1;
            while q > p do begin
                if TPcopy(s, q, length(sub)) = sub then begin
                    p := q;
                end else begin
                    q := q - 1;
                end;
            end;
        end;
        PosRight := p;
    end;

    procedure SplitBy (s: Str255; ch: char; var left, right: Str255);
        var
            p: integer;
    begin
        p := TPpos(ch, s);
        if p <= 0 then begin
            left := s;
            right := '';
        end else begin
            left := TPcopy(s, 1, p - 1);
            right := TPcopy(s, p + 1, 255);
        end;
    end;

    procedure SplitRightBy (s: Str255; ch: char; var left, right: Str255);
        var
            p: integer;
    begin
        p := PosRight(ch, s);
        if p <= 0 then begin
            left := '';
            right := s;
        end else begin
            left := TPcopy(s, 1, p - 1);
            right := TPcopy(s, p + 1, 255);
        end;
    end;

    function Split (sub, s: Str255; var s1, s2: Str255): boolean;
        var
            p: integer;
    begin
        p := TPpos(sub, s);
        if p > 0 then begin
            s1 := TPcopy(s, 1, p - 1);
            s2 := TPcopy(s, p + length(sub), 255);
        end;
        Split := p > 0;
    end;

    function SplitRight (sub, s: Str255; var s1, s2: Str255): boolean;
        var
            p: integer;
    begin
        p := PosRight(sub, s);
        if p > 0 then begin
            s1 := TPcopy(s, 1, p - 1);
            s2 := TPcopy(s, p + length(sub), 255);
        end;
        SplitRight := p > 0;
    end;

    function Match (pattern, name: Str255): boolean;
        function M (p, n: integer): boolean;
            var
                state: (searching, failed, success);
        begin
            state := searching;
            while state = searching do begin
                case ord(p <= length(pattern)) * 2 + ord(n <= length(name)) of
                    0:  begin
                        state := success;
                    end;
                    1:  begin
                        state := failed;
                    end;
                    2:  begin
                        state := success;
                        while p <= length(pattern) do begin
                            if pattern[p] <> '*' then begin
                                state := failed;
                                leave;
                            end;
                            p := p + 1;
                        end;
                    end;
                    3:  begin
                        case pattern[p] of
                            '?':  begin
                                p := p + 1;
                                n := n + 1;
                            end;
                            '*':  begin
                                p := p + 1;
                                if p > length(pattern) then begin { short circuit the * at the end case }
                                    state := success;
                                end else begin
                                    state := failed;
                                    while n <= length(name) do begin
                                        if M(p, n) then begin
                                            state := success;
                                            leave;
                                        end;
                                        n := n + 1;
                                    end;
                                end;
                            end;
                            otherwise begin
                                if name[n] <> pattern[p] then begin
                                    state := failed;
                                end;
                                n := n + 1;
                                p := p + 1;
                            end;
                        end;
                    end;
                end;
            end;
            M := state = success;
        end;
    begin
        UpperString(pattern, false);
        UpperString(name, false);
        Match := M(1, 1);
    end;

    procedure LimitStringLength (var s: string; len: integer; delimiter: char);
        var
            p: integer;
    begin
        if length(s) > len then begin
            p := TPpos(delimiter, s);
            if p <= 0 then begin
                p := length(s) div 2 + 1;
                s[p] := delimiter;
            end;
            while length(s) > len do begin
                if p > len div 2 + 1 then begin
                    Delete(s, p - 1, 1);
                    p := p - 1;
                end else begin
                    Delete(s, p + 1, 1);
                end;
            end;
        end;
    end;

    function StringToOSType (s: Str255): OSType;
        var
            t: OSType;
    begin
        s := concat(s, nul, nul, nul, nul);
        BlockMoveData(@s[1], @t, 4);
        StringToOSType := t;
    end;

    function OSTypeToString (t: OSType): Str255;
        var
            s:Str255;
    begin
        s:=concat(nul,nul,nul,nul);
        BlockMoveData(@t,@s[1],4);
        OSTypeToString:=s;
    end;

end.